home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / FORTH / FORTHMAC / OLD / TOOLS1 / !Forthmacs.lib.blockio < prev    next >
Text File  |  1996-06-13  |  1KB  |  47 lines
  1. \ The low level I/O used to implement standard Forth BLOCKs
  2.  
  3. decimal
  4. \needs sys vocabulary sys
  5. also sys also definitions
  6. 20 constant max#files
  7.  
  8. : open-block-file    ( str -- fid )
  9.     read fopen dup 0= if d# -275 throw then ;
  10.  
  11. nuser default-block-fid         \ File referenced by block-fid=0
  12. 0 default-block-fid !
  13.  
  14. : map-fid    ( fid -- fid' )
  15.     ?dup  0=
  16.     if    default-block-fid @  0=
  17.         if    p" forth.blk"  open-block-file  default-block-fid !
  18.         then
  19.         default-block-fid @
  20.     then ;
  21.  
  22. \ Seek to the correct starting address and prepare the arguments
  23. \ to the gem read or write call
  24. : setio        ( address block# fid -- address b/buf fid )
  25.     map-fid                        ( address block# fid' )
  26.     swap b/buf *  over fseek       ( address fid )
  27.     b/buf swap ;
  28.  
  29. : ?disk-abort    ( #transferred -- )    b/buf <> if d# -37 throw then  ;
  30. : (read-block)    ( addr blk# file -- )    setio fgets  ?disk-abort  ;
  31. : (write-block)    ( addr blk# file -- )    setio fputs  ;
  32.  
  33. : install-block-io    ( -- )
  34.     ['] (read-block)  is read-block
  35.     ['] (write-block) is write-block
  36.     0 default-block-fid ! ;
  37. install-block-io
  38. forth definitions
  39. : (cold-hook    (cold-hook install-block-io  ;
  40.     ' (cold-hook is cold-hook
  41.  
  42. \ Seek to end to find size
  43. : file-size    ( fid -- l )    map-fid  fsize  ;
  44. : .file        ( fid -- )    drop ." File name unknown"  ;
  45.  
  46. previous previous definitions
  47.